home *** CD-ROM | disk | FTP | other *** search
/ C/C++ Users Group Library 1996 July / C-C++ Users Group Library July 1996.iso / vol_100 / 176_01 / xldmem.c < prev    next >
Text File  |  1985-12-25  |  12KB  |  561 lines
  1. /* xldmem - xlisp dynamic memory management routines */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* useful definitions */
  9. #define ALLOCSIZE (sizeof(struct segment) + (anodes-1) * sizeof(NODE))
  10.  
  11. /* external variables */
  12. extern NODE ***xlstack,***xlstkbase,***xlstktop;
  13. extern NODE *obarray;
  14. extern NODE *xlenv;
  15. extern long total;
  16. extern int anodes,nnodes,nsegs,nfree,gccalls;
  17. extern struct segment *segs;
  18. extern NODE *fnodes;
  19. extern char buf[];
  20.  
  21. /* external procedures */
  22. extern char *malloc();
  23. extern char *calloc();
  24.  
  25. /* forward declarations */
  26. FORWARD NODE *newnode();
  27. FORWARD char *strsave();
  28. FORWARD char *stralloc();
  29.  
  30. /* cons - construct a new cons node */
  31. NODE *cons(x,y)
  32.   NODE *x,*y;
  33. {
  34.     NODE *val;
  35.     val = newnode(LIST);
  36.     rplaca(val,x);
  37.     rplacd(val,y);
  38.     return (val);
  39. }
  40.  
  41. /* consa - (cons x nil) */
  42. NODE *consa(x)
  43.   NODE *x;
  44. {
  45.     NODE *val;
  46.     val = newnode(LIST);
  47.     rplaca(val,x);
  48.     return (val);
  49. }
  50.  
  51. /* consd - (cons nil x) */
  52. NODE *consd(x)
  53.   NODE *x;
  54. {
  55.     NODE *val;
  56.     val = newnode(LIST);
  57.     rplacd(val,x);
  58.     return (val);
  59. }
  60.  
  61. /* cvstring - convert a string to a string node */
  62. NODE *cvstring(str)
  63.   char *str;
  64. {
  65.     NODE ***oldstk,*val;
  66.     oldstk = xlsave(&val,NULL);
  67.     val = newnode(STR);
  68.     val->n_str = strsave(str);
  69.     val->n_strtype = DYNAMIC;
  70.     xlstack = oldstk;
  71.     return (val);
  72. }
  73.  
  74. /* cvcstring - convert a constant string to a string node */
  75. NODE *cvcstring(str)
  76.   char *str;
  77. {
  78.     NODE *val;
  79.     val = newnode(STR);
  80.     val->n_str = str;
  81.     val->n_strtype = STATIC;
  82.     return (val);
  83. }
  84.  
  85. /* cvsymbol - convert a string to a symbol */
  86. NODE *cvsymbol(pname)
  87.   char *pname;
  88. {
  89.     NODE ***oldstk,*val;
  90.     oldstk = xlsave(&val,NULL);
  91.     val = newnode(SYM);
  92.     val->n_symplist = newnode(LIST);
  93.     rplaca(val->n_symplist,cvstring(pname));
  94.     xlstack = oldstk;
  95.     return (val);
  96. }
  97.  
  98. /* cvcsymbol - convert a constant string to a symbol */
  99. NODE *cvcsymbol(pname)
  100.   char *pname;
  101. {
  102.     NODE ***oldstk,*val;
  103.     oldstk = xlsave(&val,NULL);
  104.     val = newnode(SYM);
  105.     val->n_symplist = newnode(LIST);
  106.     rplaca(val->n_symplist,cvcstring(pname));
  107.     xlstack = oldstk;
  108.     return (val);
  109. }
  110.  
  111. /* cvsubr - convert a function to a subr or fsubr */
  112. NODE *cvsubr(fcn,type)
  113.   NODE *(*fcn)(); int type;
  114. {
  115.     NODE *val;
  116.     val = newnode(type);
  117.     val->n_subr = fcn;
  118.     return (val);
  119. }
  120.  
  121. /* cvfile - convert a file pointer to a file */
  122. NODE *cvfile(fp)
  123.   FILE *fp;
  124. {
  125.     NODE *val;
  126.     val = newnode(FPTR);
  127.     setfile(val,fp);
  128.     setsavech(val,0);
  129.     return (val);
  130. }
  131.  
  132. /* cvfixnum - convert an integer to a fixnum node */
  133. NODE *cvfixnum(n)
  134.   FIXNUM n;
  135. {
  136.     NODE *val;
  137.     val = newnode(INT);
  138.     val->n_int = n;
  139.     return (val);
  140. }
  141.  
  142. /* cvflonum - convert a floating point number to a flonum node */
  143. NODE *cvflonum(n)
  144.   FLONUM n;
  145. {
  146.     NODE *val;
  147.     val = newnode(FLOAT);
  148.     val->n_float = n;
  149.     return (val);
  150. }
  151.  
  152. /* newstring - allocate and initialize a new string */
  153. NODE *newstring(size)
  154.   int size;
  155. {
  156.     NODE ***oldstk,*val;
  157.     oldstk = xlsave(&val,NULL);
  158.     val = newnode(STR);
  159.     val->n_str = stralloc(size);
  160.     *getstring(val) = 0;
  161.     val->n_strtype = DYNAMIC;
  162.     xlstack = oldstk;
  163.     return (val);
  164. }
  165.  
  166. /* newobject - allocate and initialize a new object */
  167. NODE *newobject(cls,size)
  168.   NODE *cls; int size;
  169. {
  170.     NODE *val;
  171.     val = newvector(size+1);
  172.     setelement(val,0,cls);
  173.     val->n_type = OBJ;
  174.     return (val);
  175. }
  176.  
  177. /* newvector - allocate and initialize a new vector node */
  178. NODE *newvector(size)
  179.   int size;
  180. {
  181.     NODE ***oldstk,*vect;
  182.     int bsize;
  183.  
  184.     /* establish a new stack frame */
  185.     oldstk = xlsave(&vect,NULL);
  186.  
  187.     /* allocate a vector node and set the size to zero (in case of gc) */
  188.     vect = newnode(VECT);
  189.     vect->n_vsize = 0;
  190.  
  191.     /* allocate memory for the vector */
  192.     bsize = size * sizeof(NODE *);
  193.     if ((vect->n_vdata = (NODE **) calloc(1,bsize)) == NULL) {
  194.     findmem();
  195.     if ((vect->n_vdata = (NODE **) calloc(1,bsize)) == NULL)
  196.         xlfail("insufficient vector space");
  197.     }
  198.     vect->n_vsize = size;
  199.     total += (long) bsize;
  200.  
  201.     /* restore the previous stack frame */
  202.     xlstack = oldstk;
  203.  
  204.     /* return the new vector */
  205.     return (vect);
  206. }
  207.  
  208. /* newnode - allocate a new node */
  209. LOCAL NODE *newnode(type)
  210.   int type;
  211. {
  212.     NODE *nnode;
  213.  
  214.     /* get a free node */
  215.     if ((nnode = fnodes) == NIL) {
  216.     findmem();
  217.     if ((nnode = fnodes) == NIL)
  218.         xlabort("insufficient node space");
  219.     }
  220.  
  221.     /* unlink the node from the free list */
  222.     fnodes = cdr(nnode);
  223.     nfree -= 1;
  224.  
  225.     /* initialize the new node */
  226.     nnode->n_type = type;
  227.     rplacd(nnode,NIL);
  228.  
  229.     /* return the new node */
  230.     return (nnode);
  231. }
  232.  
  233. /* stralloc - allocate memory for a string adding a byte for the terminator */
  234. LOCAL char *stralloc(size)
  235.   int size;
  236. {
  237.     char *sptr;
  238.  
  239.     /* allocate memory for the string copy */
  240.     if ((sptr = malloc(size+1)) == NULL) {
  241.     findmem();  
  242.     if ((sptr = malloc(size+1)) == NULL)
  243.         xlfail("insufficient string space");
  244.     }
  245.     total += (long) (size+1);
  246.  
  247.     /* return the new string memory */
  248.     return (sptr);
  249. }
  250.  
  251. /* strsave - generate a dynamic copy of a string */
  252. LOCAL char *strsave(str)
  253.   char *str;
  254. {
  255.     char *sptr;
  256.  
  257.     /* create a new string */
  258.     sptr = stralloc(strlen(str));
  259.     strcpy(sptr,str);
  260.  
  261.     /* return the new string */
  262.     return (sptr);
  263. }
  264.  
  265. /* strfree - free a string */
  266. LOCAL strfree(str)
  267.   char *str;
  268. {
  269.     total -= (long) (strlen(str)+1);
  270.     free(str);
  271. }
  272.  
  273. /* findmem - find more memory by collecting then expanding */
  274. findmem()
  275. {
  276.     gc();
  277.     if (nfree < anodes)
  278.     addseg();
  279. }
  280.  
  281. /* gc - garbage collect */
  282. gc()
  283. {
  284.     NODE ***p;
  285.  
  286.     /* mark the obarray and the current environment */
  287.     mark(obarray);
  288.     mark(xlenv);
  289.  
  290.     /* mark the evaluation stack */
  291.     for (p = xlstack; p < xlstktop; )
  292.     mark(**p++);
  293.  
  294.     /* sweep memory collecting all unmarked nodes */
  295.     sweep();
  296.  
  297.     /* count the gc call */
  298.     gccalls++;
  299. }
  300.  
  301. /* mark - mark all accessible nodes */
  302. mark(ptr)
  303.   NODE *ptr;
  304. {
  305.     NODE *this,*prev,*tmp;
  306.  
  307.     /* just return on nil */
  308.     if (ptr == NIL)
  309.     return;
  310.  
  311.     /* initialize */
  312.     prev = NIL;
  313.     this = ptr;
  314.  
  315.     /* mark this list */
  316.     while (TRUE) {
  317.  
  318.     /* descend as far as we can */
  319.     while (TRUE) {
  320.  
  321.         /* check for this node being marked */
  322.         if (this->n_flags & MARK)
  323.         break;
  324.  
  325.         /* mark it and its descendants */
  326.         else {
  327.  
  328.         /* mark the node */
  329.         this->n_flags |= MARK;
  330.  
  331.         /* follow the left sublist if there is one */
  332.         if (livecar(this)) {
  333.             this->n_flags |= LEFT;
  334.             tmp = prev;
  335.             prev = this;
  336.             this = car(prev);
  337.             rplaca(prev,tmp);
  338.         }
  339.  
  340.         /* otherwise, follow the right sublist if there is one */
  341.         else if (livecdr(this)) {
  342.             this->n_flags &= ~LEFT;
  343.             tmp = prev;
  344.             prev = this;
  345.             this = cdr(prev);
  346.             rplacd(prev,tmp);
  347.         }
  348.         else
  349.             break;
  350.         }
  351.     }
  352.  
  353.     /* backup to a point where we can continue descending */
  354.     while (TRUE) {
  355.  
  356.         /* check for termination condition */
  357.         if (prev == NIL)
  358.         return;
  359.  
  360.         /* check for coming from the left side */
  361.         if (prev->n_flags & LEFT)
  362.         if (livecdr(prev)) {
  363.             prev->n_flags &= ~LEFT;
  364.             tmp = car(prev);
  365.             rplaca(prev,this);
  366.             this = cdr(prev);
  367.             rplacd(prev,tmp);
  368.             break;
  369.         }
  370.         else {
  371.             tmp = prev;
  372.             prev = car(tmp);
  373.             rplaca(tmp,this);
  374.             this = tmp;
  375.         }
  376.  
  377.         /* otherwise, came from the right side */
  378.         else {
  379.         tmp = prev;
  380.         prev = cdr(tmp);
  381.         rplacd(tmp,this);
  382.         this = tmp;
  383.         }
  384.     }
  385.     }
  386. }
  387.  
  388. /* vmark - mark a vector */
  389. vmark(n)
  390.   NODE *n;
  391. {
  392.     int i;
  393.     for (i = 0; i < getsize(n); ++i)
  394.     mark(getelement(n,i));
  395. }
  396.  
  397. /* sweep - sweep all unmarked nodes and add them to the free list */
  398. LOCAL sweep()
  399. {
  400.     struct segment *seg;
  401.     NODE *p;
  402.     int n;
  403.  
  404.     /